COMMENT ⊗   VALID 00020 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	 MacLisp portion of the E/MacLisp Interface.
C00008 00003	 αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
C00017 00004	(lap em:get-mail subr)
C00021 00005	(entry em:mail-type subr)
C00026 00006	(entry em:wait-mail subr)
C00027 00007	(entry em:mail-sfa subr)
C00028 00008	 TYI
C00030 00009	 TYO
C00031 00010	 FORCE OUTPUT
C00034 00011	(entry rcc subr)
C00037 00012	 This routine gets fresh mail to initialize the reader
C00039 00013	 This routine does a jobread into the right spot.
C00041 00014	wait-ok  
C00042 00015	(entry em:send-simple-message subr)
C00045 00016	(entry em:send-control-char subr)
C00047 00017	(entry em:init subr)
C00048 00018	send-ok
C00049 00019	(entry em:eval-protect subr)
C00050 00020	 Storage for Mail routines
C00052 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
;;; Starts with -em:jobnum- figured out from E.

(declare (mapex t)
         (setq defmacro-for-compiling ())
	 (special -em:jobnum- -em:e-commands- -em:sfa- -em:errorp- 
		  -em:control-chars- grlinel)
	 (fixnum -em:jobnum-))

(setq -em:e-commands- ()
      -em:control-chars- ()
      grlinel 72.)

(setq -em:sfa- ())

(defun em:initialize ()
       (em:get-jobnum)
       (em:init)
       (em:send-simple-message 'ok -em:jobnum-)
       (setq -em:sfa- (sfa-create (function em:mail-sfa) 0 'mail-sfa))
       (setq tyi -em:sfa-)
       (setq tyo -em:sfa-)
       t)
 
(set (symeval (implode `(,(ascii 125.),(ascii 80.))))
	      '$P)

;;; αxSLISP dsk:maclsp.dmp[1,3](elisp.ini)
;;; αnαxSLISP talks to job n(10.)
;;; α0αxSLISP types the wholine of inferior
;;; α-αxSLISP murder (i.e. negotiated suicide)
;;; α=	send arrow line or attach buffer
;;; α+nα=	send next n lines
;;; α-nα=	send previous n lines
;;; αx= <sexp>
;;; 	send comand line
;;; 
;;; Protocols: (* means not actually anticipated to be used; current
;;; implementation knows about it but does not send and/or interpret them
;;; specially)
;;; 
;;; From E to MacLisp
;;; 	Mail
;;; 	wd0:	Job# sending message
;;; 	wd1:	type of message
;;; 
;;; 2,,0:   Continuation needed
;;; 1,,0:	Short (fits in the next =30 words, ends with null byte
;;;         or falls off)
;;; 
;;; 0		no-op
;;; 1		initiating a conversation
;;; 2		ok (did the jobread)
;;; 3		SEXPs
;;; 4		explicit eof
;;; 5		control (meta) chars to follow (E macro format)
;;; 		 (or E commands (from MacLisp to E))
;;; 6		interrupt. do <esc>i <char>
;;; 7		close connection (suicide)
;;; 
;;; 	wd2:	-number of bytes,,address of buffer
;;; 		
;;; 
;;; E commands will be represented in the standard E macro manner
;;; (unless there is something better).
;;; 
;;; 
;;; Protocol is:
;;; 	E	MacLisp
;;;         ---------------
;;; 	initiate
;;; 		ok
;;; 
;;; To send a short message just a MAIL
;;; To send a long message MAIL then wait for JOBREAD acknowledge
;;; To send interrupts, just send them
;;; Acknowledgment is the short OK message
;;; 
;;; Commands needed:
;;; 	start DMP file
;;; 	send control chars
;;; 	send interrupt character (just 1 at a time)
;;; 
(lap em:get-mail subr)
(args em:get-mail (nil . 0))

	(defsym noop-type 0)
	(defsym initiate-type 1)
	(defsym ok-type 2)
	(defsym sexp-type 3)
	(defsym explicit-eof-type 4)
	(defsym ecommand-type 5)
	(defsym control-type 5)
	(defsym interrupt-type 6)
	(defsym kill-type 7)
	(defsym high-command 7)

	(defsym alpha 2)
	(defsym beta 3)
	(defsym cont-bit 2)
	(defsym short-bit 1)
	(defsym meta-mask 400)
	(defsym control-mask 200)

em:get-mail
	(skipl 0 mailinp)		;-1 means mail in and not read
	(mail 2 mailbox)		;SRCV
	(jfcl)
	(setzm 0 mailinp)
	(setzm 0 tyi-inited)
	(movei b 'nil)
	(movem b (special sail-mail-interrupt))
	(move tt mailbox)		;get the jobnum
	(skipg 0 jobnum)
	(jrst 0 gm1)
	(came tt jobnum)		;correct one?
	(jrst 0 wrongj)
   	(movem tt jobread)
gm1	(movem tt jobnum)
	(movem tt jobn2)
	(jsp t fxcons)			;number cons
	(movem a (special -em:jobnum-)) ;save it
   	(move tt (+ mailbox 1))		;type bits
	(jrst 0 em:mail-type)

true	(movei a 't)
	(popj p)
false	(movei a 'nil)
	(popj p)

(entry em:get-jobnum subr)
(args em:get-jobnum (nil . 0))
	(move tt (special sail-mail-interrupt))
	(jsp t fxcons)			;find that entry!
	(movem a (special -em:jobnum-))
	(popj p)

(entry em:set-jobnum subr)
(args em:set-jobnum (nil . 1))
	(move tt 0 a)
	(movem a (special -em:jobnum-))
	(movem tt jobnum)
	(popj p)
wrongj 	(movei a 'wrong-jobnum)
	(popj p)
(entry em:mail-type subr)
(args em:mail-type (nil . 0))

em:mail-type
	(setzm 0 explicit-eof)	;0 means nil
	(setzm 0 forcedp)
	(movei b 'nil)
	(movem b (special -em:control-chars-))
	(move tt (+ mailbox 1));type bits
	(movei a 'nil)		;short flag
	(tlne tt short-bit)
	(movei a 't)
	(movem a (special -em:shortp-))
	(movei a 'nil)
	(tlne tt cont-bit)
	(movei a 't)
	(movem a (special -em-contp-))
	(hrrzs 0 tt)		;grumble, test for range
	(skipge 0 tt)		;too low?
	 (jrst 0 unknown)	;yup, unknown
	(caile tt high-command) ;too high
	 (jrst 0 unknown)
	(xct 0 type-disp tt)	;dispatch
unknown (movei a 'unknown)
	(popj p)
type-disp
	(jrst 0 no-op)
	(jrst 0 initiate)
	(jrst 0 ok)
	(jrst 0 sexps)
	(jrst 0 explicit-eof)
	(jrst 0 cntrl)
	(jrst 0 interrupt)
	(jrst 0 kill)
no-op
	(movei a 'no-op)
	(popj p)
sexps	
	(setzm 0 eofp)		;within eof
	(skipe 0 inbytes)
	(jrst 0 snot-finished)
sresume	(move a (+ mailbox 2))	;get number of bytes
	(move tt (+ mailbox 1));type bits
	(setzm 0 tyi-inited)	;tyi not inited
	(hlrem a inbytes)	;store it
	(hlre b a)		;-number of bytes
	(idivi b 5)		;-number of words
	(jumpe c ztesch)
	(subi b 1)		;one more, bunkie
ztesch	
	(movem b inwords)
	(setom 0 mailprocessed)
	(tlne tt short-bit)	;short?
	(jrst 0 tshort)
	(pushj p transfer-buffer)
	(movei a 'sexps)
	(popj p)
tshort	(pushj p transfer-short)
	(movei a 'sexps)
	(popj p)
cntrl   
	(setzm 0 eofp)		;within eof
	(movei b 't)
	(movem b (special -em:control-chars-))
	(skipe 0 inbytes)
	(jrst 0 cnot-finished)
cresume (setzm 0 tyi-inited)	;tyi not inited
	(move tt (+ mailbox 1));type bits
	(move a (+ mailbox 2))	;get number of bytes
	(hlrem a inbytes)	;store it
	(setom 0 mailprocessed)
	(tlne tt short-bit)	;short?
	(jrst 0 tcshort)
	(pushj p transfer-buffer)
	(movei a 'control-chars)
	(popj p)
tcshort	(pushj p transfer-short)
	(movei a 'control-chars)
	(popj p)
initiate(movei a 'initiate)
	(setom 0 mailprocessed)
	(popj p)
interrupt
	(movei a 'interrupt)
	(setzm 0 mailprocessed)
	(popj p)
explicit-eof
	(setom 0 explicit-eof)
	(movei a 'eof)
	(popj p)
ok
	(movei a 'ok)
	(setzm 0 mailprocessed)
	(popj p)

kill	(pushj p send-ok)
	(calli 1 12)	;kill self

(entry snot subr)
snot-finished
	(setzm 0 tyi-inited)
	(movei a sresume)
	(movem a resume-pc)
	(movei a 'sexps)
	(popj p)

(entry cnot subr)
cnot-finished
	(setzm 0 tyi-inited)
	(movei a cresume)
	(movem a resume-pc)
	(movei a 'control-chars)
	(popj p)
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))

em:wait-mail
	(skipe 0 tyop)
	(pushj p fmail-sendit)
	(722←33 0 mailint)	;imskcl
	(mail 1 mailbox)	;WRCV
	(721←33 0 mailint)	;imskst
	(setom 0 mailprocessed)	;mail now in
	(setom 0 mailinp)	;got mail
      	(movei a 't)
	(popj p)

(entry em:mask-off subr)
(args em:mask-off (nil . 0))
	(722←33 0 mailint)	;imskcl
	(movei a 't)
	(popj p)

(entry em:mask-on subr)
(args em:mask-on (nil . 0))
	(721←33 0 mailint)	;imskst
	(movei a 't)
	(popj p)
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
	(movei a 0 b)	;operation type ignore the object
	(caie a 'which-operations)
	(jrst 0 t1)
	(movei a '(tyi tyo force-output untyi))
	(popj p)
t1	(cain a 'tyi)		;tyi?
	(jrst 0 em:mail-tyi)
	(cain a 'tyo)		;tyo?
	(jrst 0 em:mail-tyo)
	(cain a 'force-output)	;force output?
	(jrst 0 em:mail-force-output)
	(cain a 'untyi)		;untyi?
	(jrst 0 em:mail-untyi)
	(movei a 'nil)
	(popj p)

;;; TYI

(entry em:mail-tyi)
em:mail-tyi
	(skipe 0 explicit-eof)
	(jrst 0 eeof)
	(movem c eofchar)
	(skipe a (special -em:control-chars-))
	(jrst 0 read-control-chars)
	(skipe 0 untyif)
	(jrst 0 untyi2)
	(skipn 0 tyi-inited)	;not inited?
	(pushj p real-mail-refresh)
ityi	(skipn 0 inbytes)	;and nothing left?
    	(pushj p mail-refresh)
tyi1	(aosle 0 inbytes)
	(pushj p mail-refresh)
inmailok
	(ildb tt inpoint)	;get byte
	(skipl 0 tt)		;- means end of file
	(jrst 0 fix1)		;what a bum!
	(pushj p mail-refresh)
	(jrst 0 tyi1)

em:mail-untyi
	(aos 0 untyif)
	(move b untyipdl)
	(push b c)
	(movem b untyipdl)
	(popj p)

untyi2	(move b untyipdl)
	(sosl 0 untyif)
	(pop b a)
	(movem b untyipdl)
	(popj p)
	
eeof	(setzm 0 explicit-eof)

reof
	(setom 0 eofp)
	(move a eofchar)
	(sub p (% 0 0 1 1))
	(popj p)
;;; TYO

em:mail-tyo
	(setzm 0 forcedp)
	(setom 0 tyop)
	(move a @ c)
	(idpb a outpoint)	;put it there
	(sosg 0 outbytes)	;ready to send?
	(pushj p cmail-sendit)
	(cain a #o12)
	(pushj p fmail-sendit)
	(movei a 't)
	(popj p)

;;; FORCE OUTPUT

fmail-sendit
	(setom 0 forcedp)
cmail-sendit
	(movei tt cont-bit)
	(jrst 0 mail-sendit)

em:mail-force-output
(entry em:mail-force-output subr)
	(skipe 0 forcedp)
	(jrst 0 true)
	(setz tt)		;continuation
mail-sendit
	(setzm 0 tyop)
	(movei a 40)		;space
	(idpb a outpoint)
	(sos 0 outbytes)	;extra byte
	(movei a outmail)	;address of buffer
	(movem a (+ mailbox 2))
	(move a outbytes)	
	(movei a #o5000)
	(sub a outbytes)	
	(movei t 1)		;1 in t means long
	(caile a 145.)		;short enough
	(jrst 0 send-message)	;nope
	(setz t)		;0 in T means short
	(hrlzi tt outmail)
	(hrri  tt (+ mailbox 3))
	(blt tt (+ mailbox 32.))	;move to the right place
	(iori tt short-bit)
send-message
	(hrls 0 tt)		;swap
	(hrri tt sexp-type)
	(skipe 0 (special -em:e-commands-))
	(hrri tt ecommand-type)
	(movem tt (+ mailbox 1))
	(movns 0 a)
	(hrlzm a (+ mailbox 2))
	(movei a outmail)
	(hrrm a (+ mailbox 2))
	(move a thisjob)
	(movem a mailbox)
	(pushj p wait-for-clear)
	(mail 0 jobnum)		;mail it
	(jrst 0 false)
	(hrlzi a outmail)
	(hrri a (+ outmail 1))
	(setzm 0 outmail)
	(blt a (+ outmail #o1000))	;zero it
	(hrlzi a mailbox)
	(hrri a (+ mailbox 1))
	(setzm 0 mailbox)
	(blt a (+ mailbox 32.))	;zero it
	(move a outpointtem)	;setup output byte count
	(movem a outpoint)
	(movei a #o5001))
	(movem a outbytes)
	(jumpe t true)		;don't hang around
	(pushj p wait-ok)	;wait for acknowledgment
	(pushj p em:mail-type)
	(came a 'ok)
	(jrst 0 false)
	(jrst 0 true)

(entry rcc subr)
read-control-chars
	(skipe 0 untyif)
	(jrst 0 untyi2)
	(skipn 0 tyi-inited)	;tyi inited?
	(pushj p real-mail-refresh)
	(skipn 0 inbytes)
    	(pushj p mail-refresh)
	(pushj p rgetchar)
	(cain t alpha)
	(movei tt control-mask)	;saw an α
	(jrst 0 read-meta)	;now maybe a β?
	(cain t beta)		;saw a β, so now the char
	(iori t meta-mask)
read-char
	(pushj p rgetchar)
	(ior tt t)
	(jrst 0 fix1)

read-meta
	(pushj p rgetchar)
	(cain t beta)
	(iori t meta-mask)
	(jrst 0 (+ read-char 1))


rgetchar(skipe 0 untyif)
	(jrst 0 untyi2)
	(aosle 0 inbytes)
	(pushj p mail-refresh)
	(ildb t inpoint)
	(skipl 0 t)
	(cain t 40)		;space?
	(jrst 0 rgetchar)	;foo, go around
	(popj p)
rceof	(move a eofchar)
	(sub p (% 0 0 1 1))
	(popj p)
;;; This routine gets fresh mail to initialize the reader
mail-refresh
real-mail-refresh
	(skipn 0 mailprocessed)	;processed?
	(jrst 0 mr1)		;get the next batch
mr3	(pushj p em:wait-mail)	;wait for response
	(jrst 0 em:get-mail)	;get the mail

mr1	(skipn 0 resume-pc)	;ready for crock?
	(jrst 0 mr3)		;nope
    	(pushj p @ resume-pc)	;get the rest
	(popj p)		;continue
;;; This routine does a jobread into the right spot.

transfer-buffer
	(move a inpointtem)	;byte pointer template
	(movem a inpoint)
	(setom 0 tyi-inited)	;ready to read
	(movei tt jobread)
	(pushj p zinmail)
	(move a (+ mailbox 2))
	(hrl a inwords)
	(movem a (+ jobread 1))
	(calli tt 400050)	;jobrd
	(jrst 0 false)
	(jrst 0 send-ok)
	(popj p)		;good return

zinmail
	(hrlzi a inmail)
	(hrri a (+ inmail 1))
	(setzm 0 inmail)
	(blt a (+ inmail #o1000))
	(popj p)

(entry em:clear-input subr)
(args em:clear-input (nil . 0))
	(setzm 0 tyop)
	(setzm 0 forcedp)
	(setzm 0 untyif)
	(setzm 0 inbytes)
	(move a temuntyipdl)
	(movem a untyipdl)
	(setom 0 explicit-eof)
	(setom 0 eofp)
	(setzm 0 mailinp)
	(setom 0 mailprocessed)
	(setzm 0 tyi-inited)
	(pushj p zinmail)
	(movei a 't)
	(popj p)
wait-ok  
	(722←33 0 mailint)	;imskcl
	(mail 1 mailbox)	;WRCV
	(721←33 0 mailint)	;imskst
	(move tt (+ mailbox 2))
	(setzm 0 mailinp)
	(hrrzs tt)		;flush short?
	(caie tt ok-type)
	(jrst 0 true)
	(jrst 0 false)
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 2))

	(cain a 'initiate)
	(jrst 0 initiate-message)
	(cain a 'ok)
	(jrst 0 ok-message)
	(cain a 'hold-it)
	(jrst 0 hold-it-message)
	(cain a 'eof)
	(jrst 0 eof-message)
	(movei a 'Invalid-message)
	(popj p)

eof-message
	(movei a explicit-eof-type)
	(jrst 0 send-simple-message)
initiate-message
	(movei a initiate-type)
	(jrst 0 send-simple-message)
ok-message
	(movei a ok-type)
	(jrst 0 send-simple-message)
hold-it-message
	(movei a 102)
	(movem a (+ mailb2 2))
	(movei a interrupt-type)

send-simple-message
	(movem a (+ mailb2 1))
	(move b 0 b)
	(movem b jobn2)
	(movem b jobnum)
	(move b thisjob)
	(movem b mailb2)
	(movem b mailbox)
	(pushj p wait-for-clear)
     	(mail 0 jobn2)
	(jrst 0 false)
	(jrst 0 true)

wait-for-clear
	(mail 4 jobnum)
	(popj p)
	(setz tt)
	(calli tt 31)
	(jrst 0 wait-for-clear)

(entry em:send-control-char subr)
(args em:send-control-char (nil . 2))

send-control-char
	(movei t -1)		;count
	(move tt outchartem)
	(move a 0 a)		;get character
	(trze a 200)		;control bit
	(pushj p c1)		;push control
	(trze a 400)		;meta bit
	(pushj p m1)		;push meta
	(idpb a tt)
	(movei a control-type)
	(hrli a short-bit)	;short control chars
	(movem a (+ mailb2 1))
	(hrlzm t (+ mailb2 2))
	(movei a outmail)
	(hrrm a (+ mailb2 2))

	(move b 0 b)
	(movem b jobn2)
	(movem b jobnum)
	(move b thisjob)
	(movem b mailb2)
	(movem b mailbox)
	(pushj p wait-for-clear)
     	(mail 0 jobn2)
	(jrst 0 false)
	(jrst 0 true)

c1	(movei r 2)		;alpha
	(idpb r tt)		;send it
	(sos 0 t)		;decrement
	(popj p)

m1	(movei r 3)		;beta
	(idpb r tt)		;send it
	(sos 0 t)		;decrement
	(popj p)
(entry em:init subr)
(args em:init (nil . 0))

	(setzm 0 mailinp)
	(setom 0 jobnum)
	(calli tt 30)
	(movem tt thisjob)
	(jrst 0 fix1)

transfer-short

	(move a inpointtem)	;byte pointer template
	(movem a inpoint)
	(pushj p zinmail)
	(hrlzi a (+ mailbox 3))	;move from here
	(hrri a inmail)		;to here
	(blt a (+ inmail 30.))	;transfer 30
	(setom 0 tyi-inited)	;ready to read
	(popj p)

send-ok
	(movei a ok-type)
	(movem a (+ mailb2 1))
	(move b thisjob)
	(movem b mailb2)
	(pushj p wait-for-clear)
     	(mail 0 jobn2)
	(jrst 0 false)
	(jrst 0 true)
(entry em:eval-protect subr)
(args em:eval-protect (nil . 0))
(movei a mailbox)
(movem a (special sail-mail-address))
(movei a 't)
(popj p)

(entry em:eval-unprotect subr)
(args em:eval-unprotect (nil . 0))
(movei a 'nil)
(movem a (special sail-mail-address))
(popj p)
;;; Storage for Mail routines

tyop (0)
forcedp (0)		;output already forced
inwords (0)		;number of words to input via jobread
explicit-eof (-1)	;nil
eofp (-1)		;-1 means mail in and not read
mailinp (0)		;-1 means mail in and not read
mailint (4000000000)
jobnum	(0)
	(0 0 mailbox)
(entry mailbox subr)
mailbox	(block 32.)	;mail
jobn2 (0)
	(0 0 mailb2)
(entry mailb2 subr)
mailb2(block 32.)	;short mail
(entry inmail subr)
inmail	(block 1000)	;text
(entry outmail subr)
outmail	(block 1000)	;text
stack (block 20)
untyipdl (777760←22 0 stack)
temuntyipdl (777760←22 0 stack)
untyif (0)
(entry inpoint subr)
inpoint (1100←22 0 (- inmail 1))
inpointtem (1100←22 0 (- inmail 1))
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
outchartem (700←22 0 (+ mailb2 2))
outbytes (5001)
control-chars (0)
mailprocessed (-1)	;0 means not processed
tyi-inited (0)		;ready to read. 0 = nil, -1 = t
resume-pc  (0)		;where to get more chars
eofchar (0)		;eof char
thisjob (0)
jobread	(0)
	(0)
	(0 0 inmail)
()

(progn (em:initialize) (princ '|MacLisp Ready|))